home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / param.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  11.6 KB  |  311 lines
  1. (herald (front_end param)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Parameterizing procedures so that they can be easily copied
  5. ;;;
  6. ;;;    (LET ((F (LAMBDA <vars>
  7. ;;;               <stuff>
  8. ;;;               (FOO <exit1> <exit2> ... <arg1> <arg2> ...))))
  9. ;;;       <body>)
  10. ;;;  If any of the <args> are LAMBDAs they cannot reference any of <vars>
  11. ;;;  or they must be small enough to be duplicated.  <stuff> cannot reference
  12. ;;;  any of the <vars> or contain any side-effects or references to global
  13. ;;;  variables.
  14. ;;;
  15. ;;;  =>
  16. ;;;
  17. ;;;    <stuff>
  18. ;;;      (LET ((E1 (LAMBDA <vars> <exit1>))  ; These LAMBDAs are only needed if
  19. ;;;            (E2 (LAMBDA <vars> <exit2>))  ; the exits reference <vars>.
  20. ;;;            ...
  21. ;;;            (A1 <arg1>)  ; These go here only if they are LAMBDAs that do not
  22. ;;;            (A2 <arg2>)  ; reference <vars>
  23. ;;;            ...)
  24. ;;;        (LET ((F (LAMBDA <vars>
  25. ;;;                   (FOO (LAMBDA <e-vars1> 
  26. ;;;                          (E1 <vars>))  
  27. ;;;                        (LAMBDA <e-vars2>
  28. ;;;                          (E2 <vars>))  
  29. ;;;                        ...
  30. ;;;                        A1
  31. ;;;                        A2 ...))))
  32. ;;;          <body>))
  33. ;;;  Thus LAMBDA bound to F is cheap to copy as its call contains only small
  34. ;;;  pieces of node tree.
  35.  
  36. ;;; If <stuff> didn't obey the above restrictions but also didn't bind any
  37. ;;; variables that the FOO call used, the following transformation could be
  38. ;;; used:
  39. ;;;
  40. ;;;      (LET ((B (LAMBDA <vars> <stuff>))
  41. ;;;            (E1 (LAMBDA <vars> <exit1>))  ; These LAMBDAs are only needed if
  42. ;;;            (E2 (LAMBDA <vars> <exit2>))  ; the exits reference <vars>.
  43. ;;;            ...
  44. ;;;            (A1 <arg1>)  ; These go here only if they are LAMBDAs that do not
  45. ;;;            (A2 <arg2>)  ; reference <vars>
  46. ;;;            ...)
  47. ;;;        (LET ((F (LAMBDA <vars>
  48. ;;;                   (B <vars>)
  49. ;;;                   (FOO (LAMBDA <e-vars1> 
  50. ;;;                          (E1 <vars>))  
  51. ;;;                        (LAMBDA <e-vars2>
  52. ;;;                          (E2 <vars>))  
  53. ;;;                        ...
  54. ;;;                        A1
  55. ;;;                        A2 ...))))
  56. ;;;          <body>))
  57.  
  58. ;;; Top level call.
  59.  
  60. (define (parameterize l-node call)
  61.   (cond ((can-parameterize? l-node call)
  62.          (really-parameterize l-node call)
  63.          t)
  64.         (else nil)))
  65.  
  66. ;;; Can CALL be parameterized at L-NODE?  Walks up the node tree from CALL
  67. ;;; collecting all of the non-exit lambda-nodes as it goes.  Once all of the
  68. ;;; lambdas are collected they are checked to make sure they do not reference
  69. ;;; any of L-NODE's variables.
  70. ;;;
  71. ;;; Each call between CALL and L-NODE is checked to make sure it it can be
  72. ;;; moved.
  73.  
  74. (define (can-parameterize? l-node call)
  75.   (and (every? hoistable-exit? (call-exit-args call))
  76.        (direct-descendent? l-node call)
  77.        (iterate loop ((top (node-parent call))
  78.                       (nodes (filter (lambda (n) (not (leaf-node? n)))
  79.                                      (call-non-exit-args call))))
  80.          (cond ((eq? top l-node)
  81.                 (walk (lambda (l) (set (node-flag l) t))
  82.                       nodes)
  83.                 (mark-reference-parents l-node)
  84.                 (let ((res (every? node-flag nodes)))
  85.                   (walk (lambda (l) (set (node-flag l) nil))
  86.                         nodes)
  87.                   res))
  88.                ((and (call-node? (node-parent top))
  89.                      (hoistable-call? (node-parent top) top))
  90.                 (loop (node-parent (node-parent top)) 
  91.                       (append! (filter (lambda (n) (neq? n top))
  92.                                        (call-proc+args (node-parent top)))
  93.                               nodes)))
  94.                (else nil)))))
  95.  
  96. (define (hoistable-exit? node)
  97.   (or (reference-node? node)
  98.       (and (lambda-node? node)
  99.            (not (variable? (lambda-rest-var node))))
  100.       (and (object-node? node)
  101.            (or (lambda-node? (object-proc node))
  102.                (object-node? (object-proc node)))
  103.            (hoistable-exit? (object-proc node)))))
  104.  
  105. (define (direct-descendent? ancestor descendent)
  106.   (iterate loop ((node descendent))
  107.     (let ((parent (node-parent node)))
  108.       (cond ((eq? parent ancestor) t)
  109.             ((or (not (call-node? parent))
  110.                  (and (fx> 2 (call-exits parent))
  111.                       (call-exit? node)))
  112.              (loop parent))
  113.             (else nil)))))
  114.  
  115. (define (mark-reference-parents l-node)
  116.   (walk (lambda (var)
  117.           (cond ((variable? var)
  118.                  (walk (lambda (ref)
  119.                          (do ((n ref (node-parent n)))
  120.                              ((eq? n l-node))
  121.                            (set (node-flag n) nil)))
  122.                        (variable-refs var)))))
  123.         (lambda-rest+variables l-node)))
  124.  
  125. (define (hoistable-call? call from)
  126.   (let ((proc (call-proc call)))
  127.     (cond ((lambda-node? proc)
  128.            (and (eq? proc from)
  129.                 (not (any? global-reference? (call-args call)))))
  130.           ((primop-node? proc)
  131.            (and (fx= '1 (call-exits call))
  132.                 (eq? from (car (call-args call)))
  133.                 (not (primop.side-effects? (primop-value proc)))
  134.                 (not (any? global-reference? (call-args call)))))
  135.           (else
  136.            nil))))
  137.             
  138. (define (global-reference? node)
  139.   (and (reference-node? node)
  140.        (not (variable-binder (reference-variable node)))))
  141.  
  142. ;;; Use NODE-INSTRUCTIONS field to mark nodes
  143.  
  144. (define-constant node-flag
  145.   (object (lambda (n)
  146.             (node-instructions n))
  147.     ((setter self) (setter node-instructions))))
  148.  
  149. ;;;                    PARAMETERIZING A CALL
  150. ;;;============================================================================
  151.  
  152. ;;; If L-NODE is not the parent of CALL the block of code between them must
  153. ;;; be moved above L-NODE.
  154. ;;; Then the arguments to CALL are parameterized and any large ones are
  155. ;;; put into a LET above CALL.
  156.  
  157. (define (really-parameterize l-node call)
  158.   (if (neq? (node-parent call) l-node)
  159.       (move-block l-node call))
  160.   (receive (vars vals)
  161.            (parameterize-args call (lambda-rest+variables l-node))
  162.     (if (not (null? vars))
  163.         (insert-let vars vals (node-parent (node-parent l-node))))
  164.     (return)))
  165.  
  166. ;;; Move the code between L-NODE and CALL to above L-NODE
  167.  
  168. (define (move-block l-node call)
  169.   (let ((new-top-call (detach (lambda-body l-node))))
  170.     (move (node-parent l-node)
  171.           (lambda (old-top-call)
  172.             (move call
  173.                   (lambda (call)
  174.                     (relate lambda-body l-node call)
  175.                     old-top-call))
  176.             new-top-call))))
  177.  
  178. ;;; VARS are bound to VALS in a let-node just below PARENT.
  179.  
  180. (define (insert-let vars vals parent)
  181.   (let ((new-proc (create-lambda-node 'l (cons-from-freelist nil vars)))
  182.         (new-call (create-call-node (fx+ '1 (length vals)) '0)))
  183.     (relate-call-args new-call vals)
  184.     (relate call-proc new-call new-proc)
  185.     (move (lambda-body parent)
  186.           (lambda (call)
  187.             (relate lambda-body new-proc call)
  188.             new-call))))
  189.  
  190. ;;; Walk down the arguments to CALL, replacing non-leaf nodes with variables.
  191. ;;; Returns a list of the new variables and the values they should be bound
  192. ;;; to.  Exits require a little more work as they may contain references to
  193. ;;; SCOPE-VARS.
  194.  
  195. (define (parameterize-args call scope-vars)
  196.   (iterate loop ((args (copy-list (call-args call))) (exits (call-exits call))
  197.                  (vars '()) (vals '()))
  198.     (cond ((null? args)
  199.            (return (reverse! vars) (reverse! vals)))
  200.           ((leaf-node? (car args))
  201.            (loop (cdr args) (fx- exits '1) vars vals))
  202.           ((fx< '0 exits)
  203.            (let ((role (node-role (car args))))
  204.              (receive (new var val)
  205.                       (parameterize-exit (detach (car args)) scope-vars)
  206.                (relate role call new)
  207.                (mark-changed new)
  208.                (loop (cdr args) (fx- exits '1)
  209.                      (cons-from-freelist var vars) (cons val vals)))))
  210.           (else
  211.            (let ((let-var (create-variable 'c)))
  212.              (move (car args)
  213.                    (lambda (#f)
  214.                      (create-reference-node let-var)))
  215.              (loop (cdr args) '0
  216.                    (cons let-var vars) (cons (car args) vals)))))))
  217.  
  218. ;;;    (LAMBDA (<cvars>) <cont>) + <vars>
  219. ;;; => 
  220. ;;;   If <cont> doesn't reference <vars>:
  221. ;;;
  222. ;;;     v                                     {new continuation}
  223. ;;;     v                                     {variable for LET}
  224. ;;;     (LAMBDA (<cvars>) <cont>)             {value for LET}
  225. ;;;
  226. ;;;   IF <cont> references <vars> and <cvars> is empty:
  227. ;;;
  228. ;;;     (LAMBDA () (c <vars>))                {new continuation}
  229. ;;;     c                                     {variable for LET}
  230. ;;;     (LAMBDA (<vs>) <cont>[<vs>/<vars>])   {value for LET}
  231. ;;;
  232. ;;;   Otherwise:
  233. ;;;
  234. ;;;     (LAMBDA (<cvs0>) (c <cvs0> <vars>))   {ditto}
  235. ;;;     c
  236. ;;;     (LAMBDA (<cvs1> <vs>) <cont>[<vs>/<vars>][<cvs1>/<cvars>])
  237.  
  238. (define (parameterize-exit node vars)
  239.   (let ((exit-vars (proc-variables node)))
  240.     (receive (new-vars old-vars)
  241.              (replace-needed-vars node vars)
  242.       (cond ((null? new-vars)
  243.              (let ((let-var (create-variable 'c)))
  244.                (return (create-reference-node let-var) let-var node)))
  245.             ((null? exit-vars)
  246.              (let ((let-var (create-variable 'c))
  247.                    (old-refs (map create-reference-node old-vars))
  248.                    (let-body (detach (lambda-body node))))
  249.                (let-nodes ((new-cont (()) ((* let-var) '0 . old-refs))
  250.                            (let-value (() . new-vars) let-body))
  251.                  (erase-all node)
  252.                  (return new-cont let-var let-value))))
  253.             (else
  254.              (messy-parameterize-exit node exit-vars new-vars old-vars))))))
  255.  
  256. ;;; LAMBDA-VARIABLES that works on object-nodes as well.
  257.  
  258. (define (proc-variables node)
  259.   (cond ((lambda-node? node)
  260.          (lambda-variables node))
  261.         ((object-node? node)
  262.          (proc-variables (object-proc node)))
  263.         (else
  264.          (bug "PROC-VARIABLES: node ~S has no variables."))))
  265.  
  266. ;;; Replace any of VARS that are referenced in NODE with references to new
  267. ;;; variables, returning a list of any new variables and a corresponding list
  268. ;;; of the VARS they replaced.
  269.  
  270. (define (replace-needed-vars node vars)
  271.   (let ((new-vars (map (lambda (var) (if (used? var) (create-variable 'w) nil))
  272.                        vars)))
  273.     (substitute-vars-in-node-tree node vars new-vars)
  274.     (let ((l (filter! (lambda (p) (used? (car p)))
  275.                       (map cons new-vars vars))))
  276.       (return (free-map car l) (map cdr l)))))
  277.  
  278. ;;; Full blown PARAMETERIZE-EXIT.
  279. ;;;    (LAMBDA (<cvars>) <cont>) + <vars>
  280. ;;; => 
  281. ;;;    (LAMBDA (<cvs0>) (c1 <cvs0> <vars>))                       {new-cont}
  282. ;;;    c1                                                         {let-var}
  283. ;;;    (LAMBDA (<cvs1> <vs>) <cont>[<vs>/<vars>][<cvs1>/<cvars>]) {let-value}
  284.  
  285. (define (messy-parameterize-exit node exit-vars new-vars old-vars)
  286.   (let* ((let-var (create-variable 'c))
  287.          (new-exit-vars0 (copy-var-list exit-vars))
  288.          (new-exit-vars1 (copy-var-list exit-vars))
  289.          (refs (map create-reference-node (append new-exit-vars0 old-vars)))
  290.          (let-value-vars (append new-exit-vars1 new-vars))
  291.          (let-value-body (detach (lambda-body node))))
  292.     (substitute-vars-in-node-tree let-value-body exit-vars new-exit-vars1)
  293.     (let-nodes ((new-cont (() . new-exit-vars0) ((* let-var) 0 . refs))
  294.                 (let-value (() . let-value-vars) let-value-body))
  295.       (erase-all node)
  296.       (return new-cont let-var let-value))))
  297.  
  298. (define (copy-var-list l)
  299.   (free-map (lambda (v)
  300.               (if (used? v)
  301.                   (create-variable (variable-name v))
  302.                   nil))
  303.             l))
  304.  
  305.  
  306.  
  307.  
  308.  
  309.  
  310.  
  311.